unit HTTPTools;

interface

uses
  SysUtils, Classes, Contnrs, HTTPApp, HTTPProd;

type
  TTagHandler = procedure( const TagName: string; TagParams: TStrings; var TagValue: string ) of object;

  TTagsManager = class
  private
    FOwner : TObject;
    FTags : TStringList;
    {FStripParamQuotes : boolean;}
  public
    PageProducer : TPageProducer;
    procedure AddTag( const TagName: string; Handler: TTagHandler );
    function  TagValue( const TagName: string; TagParams: TStrings ): string;
    function  ReplaceTagsParams( const s: string ): string;
    function  TagParamValue(TagsParams: TStrings; const ParamName: string; const Def: string= ''): string;
    constructor create(Owner: TObject);
    destructor destroy; override;
    {property StripParamQuotes : boolean read FStripParamQuotes;}
  end;

  TPartContent = class
  private
    FContentDisposition : string;
    FContentType : string;
    FFields : TStrings;
    FContent : string;
    FName : string;
    procedure ParseData( data: string );
  public
    constructor Create( const data: string );
    destructor Destroy; override;
    function FieldByName( const FieldName: string ): string;
    property ContentDisposition: string read FContentDisposition;
    property ContentType: string read FContentType;
    property Fields: TStrings read FFields;
    property Content: string read FContent;
    property Name: string read FName;
  end;

  TMultipartContent = class
  private
    FParts : TObjectList;
    FRequest : TWebRequest;
    function GetParts(idx: integer): TPartContent;
    procedure SetRequest(const Value: TWebRequest);
    function GetPartCount: integer;
  public
    constructor Create( ARequest: TWebRequest );
    destructor Destroy; override;
    procedure ParseContent;
    function IndexOfPart( const Name: string ): integer;
    function PartByName( const Name: string ): TPartContent;
    property PartCount: integer read GetPartCount;
    property Parts[ idx: integer ]: TPartContent read GetParts;
    property Request: TWebRequest read FRequest write SetRequest;
  end;

function ReplaceSpecialCharacters(const s:string):string;

implementation

uses
  StrTools;

{ TTagsManager }

constructor TTagsManager.create(Owner: TObject);
begin
  inherited create;
  FOwner := Owner;
  FTags := TStringList.create;
  FTags.Duplicates := dupIgnore;
  FTags.Sorted := true;
end;

destructor TTagsManager.destroy;
var i:Integer;
begin
  with FTags do
  begin
    for i:=0 to Count-1 do
      Dispose(Pointer(Objects[i]));
    Free;
  end;
  inherited;
end;

procedure TTagsManager.AddTag(const TagName: string; Handler: TTagHandler);
  var p:^TMethod;
begin
  new(p);
  p^ := TMethod(Handler);
  FTags.AddObject(TagName,TObject(p));
end;

function TTagsManager.ReplaceTagsParams(const s: string): string;
var
  i     : integer;
  modo  : (busqueda,tag);
  t     : string;
begin
  result := '';
  i := 1; modo := busqueda;
  while i<=length(s) do
  begin
    case modo of
      busqueda:
        if (s[i]='[') {and (i<length(s)) and (s[i+1]='#')} then
        begin
          modo := tag;
          t := '';
          {inc(i);}
        end
        else result := result+s[i];
      tag:
        if s[i]=']' then
        begin
          {k := GetParam(' ',t);
          pl := TStringList.Create;
          ExtractHTTPFields([' '], [' '], PChar(t), pl, FStripParamQuotes);
          r := TagValue(k, pl);
          pl.Free;
          result := result+r;}
          result := result+PageProducer.ContentFromString('<'+t+'>');
          modo := busqueda;
        end
        else t := t+s[i];
    end;
    inc(i);
  end;
end;

function ReplaceSpecialCharacters(const s:string):string;
  var i,k:integer; 
  function reemplazo(const s:string):string;
    var t:string;
  begin
    t := Uppercase(Copy(s,2,2));
    if t='PL' then t := '+' else
    if t='NL' then t := '' else
    if t='SQ' then t := '''' else
    if t='DQ' then t := '"' else
    if t='GT' then t := '>' else
    if t='LT' then t := '<' else
    if t='GE' then t := '>=' else
    if t='LE' then t := '<=' else
    if (t>'') and (t[1]='&') then t := Copy(t,1,length(t));
    k := length(t);
    result := t +Copy(s,4,length(s));
  end;
begin
  result := s; i:=1;
  while i<length(result) do
  begin
    if result[i]='&' then
      result := Copy(result,1,i-1)+reemplazo(Copy(result,i,length(result)))
    else
      k := 1;
    Inc(i,k);
  end;
end;

function TTagsManager.TagParamValue(TagsParams: TStrings; const ParamName,  Def: string): string;
begin
  result := ReplaceTagsParams(TagsParams.Values[ParamName]);
  if result='' then result := Def;
end;

function TTagsManager.TagValue(const TagName: string; TagParams: TStrings): string;
var
  i : integer;
  h : ^TTagHandler;
  t : string;
begin
  result := '';
  t := UpperCase(TagName);
  i := FTags.IndexOf(t);
  if i<0 then exit;
  TagParams.text := ReplaceSpecialCharacters(TagParams.text);
  h := pointer(FTags.Objects[i]);
  h^(t,TagParams,result);
end;

{ TPartContent }

const
  EOL = #13#10;

function GetLine( var s : string ): string;
begin
  result := GetParam(EOL,s);
end;

procedure TPartContent.ParseData( data: string );
var
  l,c : string;
begin
  FFields.Clear;
  GetLine(data);
  if data='' then exit;
  l := GetLine(data);
  c := UpperCase(GetParam(':',l));
  if c<>'CONTENT-DISPOSITION' then exit;
  FContentDisposition := Trim(GetParam(';',l));
  ExtractHTTPFields([';'],[' '],PChar(l),FFields,true);
  FName := FFields.Values['NAME'];
  l := GetLine(data);
  if l>'' then
  begin
    c := UpperCase(Trim(GetParam(':',l)));
    if c='CONTENT-TYPE' then FContentType := Trim(l);
    repeat
      l := GetLine(data);
    until l='';
  end;
  FContent := copy(data,1,length(data)-4);
end;

constructor TPartContent.Create( const data: string );
begin
  inherited Create;
  FFields := TStringList.Create;
  ParseData(data);
end;

destructor TPartContent.Destroy;
begin
  FFields.Free;
  inherited;
end;

function TPartContent.FieldByName(const FieldName: string): string;
begin
  result := Fields.Values[FieldName];
end;

{ TMultipartContent }

constructor TMultipartContent.Create(ARequest: TWebRequest);
begin
  inherited Create;
  FParts := TObjectList.Create;
  Request := ARequest;
end;

destructor TMultipartContent.Destroy;
begin
  FParts.Free;
  inherited;
end;

function TMultipartContent.GetPartCount: integer;
begin
  result := FParts.Count;
end;

function TMultipartContent.GetParts(idx: integer): TPartContent;
begin
  result := FParts[idx] as TPartContent;
end;

function TMultipartContent.IndexOfPart(const Name: string): integer;
begin
  for result := 0 to PartCount-1 do
    if UpperCase(Parts[result].Name)=UpperCase(Name) then exit;
  result := -1;
end;

procedure TMultipartContent.ParseContent;
var
  boundary : string;
  content  : string;
  t,x      : string;
begin
  FParts.Clear;
  if Request=nil then exit;
  x := Request.ContentType;
  t := UpperCase(Trim(GetParam(';',x)));
  if t<>'MULTIPART/FORM-DATA' then exit;
  t := UpperCase(Trim(GetParam('=',x)));
  if t<>'BOUNDARY' then exit;
  boundary := x;
  content := Request.Content;
  while Length(content)<Request.ContentLength do
    content := content+Request.ReadString(Request.ContentLength-length(content));
  GetParam(boundary,content);
  while (content>'') and (content<>'--'+EOL) do
    FParts.Add(TPartContent.Create(GetParam(boundary,content)));
end;

function TMultipartContent.PartByName(const Name: string): TPartContent;
var
  i : integer;
begin
  i := IndexOfPart(Name);
  if i>=0 then result := Parts[i] else result := nil;
end;

procedure TMultipartContent.SetRequest(const Value: TWebRequest);
begin
  if FRequest=Value then exit;
  FRequest := Value;
  ParseContent;
end;

end.
